home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
The World of Computer Software.iso
/
oobpls10.zip
/
OFLGIF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-11-06
|
9KB
|
368 lines
{$F+,O+,T-,X+}
unit OfLGIF; {simple offline GIF decoder}
{.$DEFINE Debug}
interface
uses
DOS,
OpInline,
OpRoot,
OpCrt,
OpMouse,
OpDrag,
OpString,
DeGIF,
GIFVideo;
const
UnitVers = '1.0d';
UnitDate = '05-Jun-91';
function DisplayGIFOffLine(FN : String) : Boolean;
implementation
const
BuffSize = 8192;
YInc : Array[1..6] of Byte = (8,8,4,2,1,0);
YLin : Array[1..6] of Byte = (0,4,2,1,0,0);
YInt : Array[1..6] of Byte = (7,3,1,0,0,0);
type
BuffType = Array[1..$FFF1] of Byte;
BuffPtr = ^BuffType;
PCmt = ^CmtLine;
CmtLine =
object(DoubleListNode)
Line : String[80];
end;
var
GIFBuff : BuffPtr;
GRec : JumpRecord;
Pass : Byte;
Intrlace : Boolean;
Image : Word;
Done : Boolean;
GIFCap : Boolean;
BufIdx : Word;
Count : Word;
EOFin : Boolean;
SigOK : Boolean;
CmtList : DoubleList;
{-------------------------------}
{ High-level online GIF decoder }
{-------------------------------}
procedure RingBell;
{-make a noise}
begin
Sound(440);
Delay(100);
NoSound;
end;
function CheckKey : Boolean;
{-return True if abort is requested via pressing <ESC>}
begin
if (KeyPressed) and (ReadKey = #27) then
CheckKey := True
else
CheckKey := False;
end;
procedure EndIt(B : Boolean);
{-abort the decode process}
begin
if GraphOn then
SetTextMode;
if B then begin
RingBell;
RingBell;
end;
LongJump(GRec,1);
end;
function FileGetByte : Byte;
{-our decoder's GetByte function}
var
B : Byte;
begin
if BufIdx > Count then begin
BlockRead(GifFile, GifBuff^, BuffSize, Count);
BufIdx := 1;
end;
FileGetByte := GifBuff^[BufIdx];
Inc(BufIdx);
end;
procedure MyPutLine;
{-our decoder's PutLine proc. This method accomodates interlaced GIFs}
var I : Integer;
begin
if CheckKey then
EndIt(False);
if YCord <= Raster then {don't wrap back to top of screen!}
PlotLine(YCord);
Inc(YCord,YInc[Pass]);
if YCord >= BotEdge then begin
if Pass < 5 then Inc(Pass);
YCord := YLin[Pass] + TopEdge;
end;
end;
procedure MyPutLineDbl;
{-our decoder's PutLine proc. This method accomodates interlaced GIFs}
var I : Integer;
begin
if CheckKey then
EndIt(False);
if YCord <= Raster then {don't wrap back to top of screen!}
PlotLine(YCord);
Inc(YCord,YInc[Pass] shl 1);
if YCord >= BotEdge then begin
if Pass < 5 then Inc(Pass);
YCord := (YLin[Pass] shl 1) + TopEdge;
end;
end;
procedure AdjustVars;
{-match decode/display vars to image sizes}
var I : Byte;
begin
Inc(Image);
Pass := 5;
IntrLace := FALSE;
LeftEdge := ImageLeft;
TopEdge := ImageTop;
if (ScrWidth = 300) and (ScrHeight = 200) then begin
Inc(LeftEdge, 10);
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end
else if (ScrWidth = 378) and (ScrHeight = 240) then begin
if (DoDbl) then begin
RightEdge := 700;
BotEdge := 480;
end
else begin
Inc(LeftEdge, 131);
Inc(TopEdge, (Raster shr 1) - 120);
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end;
end
else begin
if ImageWidth < Pixels then
Inc(LeftEdge, (Pixels shr 1) - (ImageWidth shr 1));
if ImageHeight < Raster then
Inc(TopEdge, (Raster shr 1) - (ImageHeight shr 1));
RightEdge := ImageWidth + LeftEdge;
BotEdge := ImageHeight + TopEdge;
end;
YCord := TopEdge;
if Maps[Local].Interlaced then
Pass := 1;
end;
procedure LoadComments;
var
Blk : GifBlockType;
P : PCmt;
S : String;
I : Integer;
begin
S := '';
while GetExtendBlock(Blk) do begin
for I := 1 to Blk[0] do
case Chr(Blk[i]) of
#13:
begin
New(P, Init);
if P <> nil then begin
P^.Line := S;
CmtList.Append(P);
end;
S := '';
end;
#0..#31:
;
else
S := S + Chr(Blk[i]);
end;
end;
end;
procedure ShowComments;
var
P : PCmt;
W : Word;
C : Char absolute W;
begin
ClrScr;
P := PCmt(CmtList.Head);
while P <> nil do begin
WriteLn(P^.Line);
P := PCmt(P^.dlNext);
end;
repeat
W := ReadKeyOrButton;
until (C = #13) or (C = #27) or (Hi(W) in [$ED,$EE,$EF]);
end;
function DecodeGIFFile : Integer;
{-lowlevel GIF decode routine}
var I : Integer;
BlockType : Char;
Blk : GifBlockType;
ExtFunc : Byte;
begin
{init vars}
Done := False;
Image := 0;
CurMap := Global;
DecodeGIFFile := -9;
{verify signature. To accomodate future versions, we accept anything}
{with the first 3 chars "GIF" and the next 3 as 2 digits and a lower }
{case char. }
GetGIFSig;
if (Pos('GIF',GIFSig) <> 1) or
(NOT(GIFSig[4] in ['0'..'9'])) or
(NOT(GIFSig[5] in ['0'..'9'])) or
(NOT(GIFSig[6] in ['a'..'z'])) then begin
{$IFDEF Debug}
WriteLn('Failed decoding signature '+GIFSig);
{$ENDIF}
Sound(440);
Delay(100);
NoSound;
delay(2000);
EndIt(False);
end;
{get the hardware specifics, match a video mode as close as we can}
GetScrDes(Maps[CurMap]);
SelMode := SelectMode(ScrWidth,ScrHeight);
if SelMode = 0 then EndIt(True);
{if we have a global map, process it}
if Maps[Global].MapExists then
DoMapping
else
SetDefMap;
{kick into graphics mode then juggle the palette to match our map}
if (CurrentDisplay in [EGA,VGA]) and
(ScrWidth = 378) and
(ScrHeight = 240) then
if DoDbl then
PutLine := MyPutLineDbl;
SetGraphicsMode(SelMode);
AdjustPalette(SelMode);
{loop reading blocks and processing...}
while NOT Done do begin
BlockType := Chr(GetByte);
case BlockType of
',': begin {"Local descriptor", process...}
GetImageDescription(Maps[Local]);
AdjustVars;
CurMap := Global;
if Maps[Local].MapExists then begin
{juggle palette again}
CurMap := Local;
DoMapping;
AdjustPalette(SelMode);
end;
{decode the image data and display}
I := ExpandGIF;
if I <> 0 then begin
DecodeGIFFile := I;
EndIt(True);
end;
end;
'!': begin {"Extension" block...}
ExtFunc := GetExtendFunc; {get the function type}
case ExtFunc of
$FE:
LoadComments; {load comments for later}
else
while GetExtendBlock(Blk) do ; {discard the block}
end;
end;
';': begin {Terminator seen, clean up and go home}
Done := True;
DecodeGIFFile := 0;
exit;
end;
end;
end;
end;
function DisplayGIFOffLine(FN : String) : Boolean;
{-display a GIF file onscreen}
var L : LongInt;
W : Word;
C : Char Absolute W;
N : Integer;
begin
DisplayGIFOffLine := False;
{point to our routines}
GetByte := FileGetByte;
PutLine := MyPutLine;
if NOT GetMemCheck(GIFBuff,BuffSize) then exit;
CmtList.Init;
{init error handler}
N := SetJump(GRec);
if N <> 0 then begin
Close(GifFile);
if IOResult = 0 then ;
CmtList.Done;
FreeMemCheck(GIFBuff, BuffSize);
exit;
end;
{init capture file}
Count := 0;
BufIdx := 999;
Assign(GifFile, FN);
Reset(GifFile, 1);
if IOResult <> 0 then begin
CmtList.Done;
FreeMemCheck(GIFBuff, BuffSize);
exit;
end;
{process...}
N := DecodeGIFFile;
if N = 0 then begin
RingBell;
DisplayGIFOffline := True;
{wait for <CR> or <ESC> before clearing}
repeat
W := ReadKeyOrButton;
until (C = #13) or (C = #27) or (Hi(W) in [$ED,$EE,$EF]);
ClearMouseEvents;
SetTextMode;
Close(GifFile); if IOResult = 0 then ;
if CmtList.Size <> 0 then
ShowComments;
end;
CmtList.Done;
FreeMemCheck(GIFBuff, BuffSize);
end;
end.